home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / pascal / facilis.zip / STEST.PAS < prev    next >
Pascal/Delphi Source File  |  1985-03-05  |  6KB  |  180 lines
  1. program stest;
  2.  
  3. { a program to exercise the string functions of the Facilis compiler }
  4.  
  5. { by Anthony M. Marcy
  6.   updated: 11 Jan 85  }
  7.  
  8. var
  9.   i,j,n,e: integer;
  10.  
  11. procedure one;
  12.  
  13. const
  14.   con = 'a constant string';
  15.   v = 'a constant string';
  16.   w = v;
  17.  
  18. type
  19.   atyp = array[1..10] of string;
  20.   rtyp = record
  21.            h:integer;
  22.            s:string;
  23.          end;
  24.  
  25. var
  26.   p,q,r,s,t : string;
  27.   s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11,s12,s13,s14,s15,s16,s17: string;
  28.   a: atyp;
  29.   ch,c,c1: char;
  30.   rec,rec2:rtyp;
  31.   carray: array[1..5] of char;
  32.   re: real;
  33.  
  34.   procedure parpass(var v1,v2: string; v3:string; v4:atyp);
  35.  
  36.     procedure level_2(var w1: string);
  37.  
  38.     begin
  39.       w1 := w1 + 'r';
  40.     end;
  41.  
  42.   begin
  43.     v1 := v1 + 'mete';
  44.     v3 := v3 + 'mete';
  45.     level_2(v1); level_2(v3);
  46.     v2 := v3;
  47.     if v4[5] <> 'Value para' then begin
  48.       writeln('***ARRAY VAL PARAM FAILURE'); e := e+1; end;
  49.     V4[5] := 'a long dummy string';
  50.   end; {parpass}
  51.  
  52. begin  {one}
  53.   write('''','7 chars long':7,'''');
  54.     writeln('            =   ''7 chars ''');
  55.   write('''','13 cha'+'rs long':13,'''');
  56.     writeln('      =   ''13 chars long''');
  57.   writeln('''',w,'   =   ''a constant string''');
  58.   if w <> v then begin
  59.     writeln('***CONSTANT DECLARATION FAILURE'); e := e+1; end;
  60.   s1 := 'a literal string'; write('''',s1,'''');
  61.      writeln('   =   ''a literal string''');
  62.   s2 := 'assignment';
  63.   t := s2; write('''',t,'''');
  64.     writeln('         =   ''assignment''');
  65.  
  66.   s := 'ab';
  67.   if not (('abc'='abc') and (s+'d'>'abc') and ('abc'<'abd') and ('abc'>'ab')
  68.     and (s<>'ba') and ('a'<'abc') and ('b'>s+'c') and ('abc'>'a')
  69.     and (s+'c'<'b'))
  70.     or ((s+s)=s) or ('a'>'b') or ('ba'<=copy(s,1,1)+'b')
  71.     or (s>=('a'+'b'+'c'))
  72.     then begin
  73.       writeln('***RELATIONAL OPERATOR FAILURE'); e := e+1; end;
  74.  
  75.   t := 'arrays and records';
  76.   a[7] := t; rec.s := a[7]; s3 := rec.s;
  77.   write('''',s3,'''');
  78.     writeln(' =   ''arrays and records''');
  79.   rec2 := rec; rec2.s := 'X';
  80.   if (rec.s <> t) or (rec2.s <> 'X')
  81.     then begin
  82.       writeln('***RECORD ASSIGNMENT FAILURE'); e := e+1; end;
  83.  
  84.   c := 's'; s4 := c; write('''',s4,'tring := char''');
  85.     writeln('     =   ''string := char''');
  86.   s5 := t;  s5 := 'c';  c := s5; write('''',c,'har := string''');
  87.     writeln('     =   ''char := string''');
  88.   if (s4 <> 's') or (c <> 'c')
  89.     then begin
  90.       writeln('***CHAR ASSIGNMENT FAILURE'); e := e+1; end;
  91.  
  92.   s6 := 'h' + 'a'; write('''char + c',s6,'r''');
  93.     writeln('        =   ''char + char''');
  94.   s7 := 'c' + 'har'; write('''',s7,' + string''');
  95.     writeln('      =   ''char + string''');
  96.   s8 := 'cha' + 'r'; write('''string + ',s8,'''');
  97.     writeln('      =   ''string + char''');
  98.   s9 := 'string'; s9 := s9+' + '+s9; write('''',s9,'''');
  99.     writeln('    =   ''string + string''');
  100.   if (s6 <> 'ha') or (s7 <> 'char') or (s8 <> 'char')
  101.     or (s9 <> 'string + string')
  102.     then begin
  103.       writeln('***CONCATENATION FAILURE'); e := e+1; end;
  104.  
  105.   writeln; write('Please enter a string: ');
  106.   read(s17);
  107.   writeln( 'Your string is        ''',s17,''''); writeln;
  108.  
  109.   s := 'ghCopy fudd'; s10 := copy(s,3,7); writeln(s10,'nction');
  110.   s14 := copy('XXXtemp '+'stringXXX',4,11);
  111.   c := 'A'; s15 := copy(c,1,1);
  112.   s11 := copy('XXXXrightstring',5);
  113.   if (s14 <> 'temp string') or (s15 <> 'A') or (s11 <> 'rightstring')
  114.     then begin
  115.       writeln('***COPY FUNCTION FAILURE'); e := e+1; end;
  116.  
  117.   q := 'avprnlwcif'; s := 'Pos fu'; n := pos('f',s);
  118.   writeln(s,q[n],'ction');
  119.   if (pos('lw',q) <> 6) or (pos('za','z'+q) <> 1) or (pos('',q) <> 0)
  120.     or (pos(q,'') <> 0) or (pos('wc'+'ifx',q) <> 0)
  121.     or (pos('ci'+'fx',q+'xu') <> 8) or (n <> 5)
  122.     then begin
  123.       writeln('***POS FUNCTION FAILURE'); e := e+1; end;
  124.  
  125.   s := 'gnixednI gnirtS'; for n := 15 downto 1 do write(s[n]); writeln;
  126.     if (s[1] <> 'g') or (s[13] <> 'r')
  127.       then begin
  128.         writeln('***INDEXING FAILURE'); e := e+1; end;
  129.  
  130.   q := ' dummy';
  131.   if (length(q) <> 6) or (length(q+s) <> 21)
  132.      or (length('') <> 0) or (length('Q') <> 1)
  133.      then begin
  134.        writeln('***LENGTH FUNCTION FAILURE'); e := e+1; end;
  135.  
  136.   s12 := 'Var para'; q := 'Value para'; t := 'oops'; a[5] := q;
  137.   parpass(s12,t,q,a); writeln(s12); writeln(t);
  138.   if (q <> 'Value para') or (a[5] <> 'Value para')
  139.     then begin
  140.       writeln('***VALUE PARAMETER CHANGED'); e := e+1; end;
  141.  
  142.   carray := 'charXr'; carray[5] := 'a'; s16 := carray;
  143.   carray := 'rr'+'ay'; s := carray;
  144.     if (s16 <> 'chara') or (s <> 'rray ')
  145.       then begin
  146.         writeln('***CHAR ARRAY NOT COMPATIBLE'); e := e+1; end;
  147.  
  148.   if (str(-12345) <> '-12345') or (str(765.4321E21) <> '  7.6543210000E+23')
  149.     then begin
  150.       writeln('***STR FUNCTION FAILURE'); e := e+1; end;
  151.  
  152.   if (val('12345') <> 12345) or (val('-111'+'11') <> -11111)
  153.     then begin
  154.       writeln('***VAL FUNCTION FAILURE'); e := e+1; end;
  155.   if (rval('12345678.0') <> 1.2345678e7) or (rval('3.1'+'416') <> 3.1416)
  156.     then begin
  157.       writeln('***RVAL FUNCTION FAILURE'); e := e+1; end;
  158.  
  159.   writeln('four null strings: ''','','''   ''',copy(c,4,1),'''   ''',
  160.       copy('xx',-3,2),'''   ''',copy('xx',1,-3),'''');
  161.  
  162. end; {one}
  163.  
  164. begin  {main}
  165.   e := 0; writeln; writeln;
  166.   writeln('                STEST.PAS -- string testing program'); writeln;
  167.   i := maxavail;
  168.   one;
  169.   j := maxavail; writeln;
  170.   if i <> j then writeln('***GARBAGE COLLECTION FAILURE')
  171.             else writeln('garbage collection OK');
  172.   writeln; writeln('STRING TESTING COMPLETED');
  173.   if e > 0 then write(e) else write('NO');
  174.   writeln(' ERRORS FOUND');
  175.   writeln;
  176.  
  177. end.
  178.  
  179.  
  180.